home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / mixins.em < prev    next >
Lisp/Scheme  |  1993-07-13  |  5KB  |  170 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: mixins.em
  4. ;; Date: Fri Apr 16 16:20:24 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule mixins
  11.   (eulisp0
  12.    )
  13.   ()
  14.   
  15.   (defun detect (fn lst)
  16.     (if (null lst) nil
  17.       (or (fn (car lst)) 
  18.       (detect fn (cdr lst)))))
  19.   
  20.   (export <mixin-class> <mixin-base-class>)
  21.  
  22.   (defclass <mixin-class> (<mi-class>) 
  23.     ()
  24.     predicate mixin-class-p
  25.     metaclass <class>)
  26.  
  27.   (defclass <mixin-base-class> (<class>)
  28.     ()
  29.     predicate mixin-base-p
  30.     metaclass <class>)
  31.  
  32.   ;; compatability
  33.   (defmethod compatible-superclasses-p ((cl <mixin-class>) lst)
  34.     (and (call-next-method)
  35.      (not (detect (lambda (x)
  36.             (not (or (mixin-class-p x)
  37.                  (eq x <object>))))
  38.               lst))))
  39.   
  40.   (defun check-reps (lst reps)
  41.     (cond ((null lst) t)
  42.       ((eq (car lst) object)
  43.        (check-reps (cdr lst) reps))
  44.       ((memq (car lst) reps) nil)
  45.       (t (check-reps (cdr lst) (cons (car lst) reps)))))
  46.  
  47.   ;; don't call next method as we are specialising single inheritance
  48.   (defmethod compatible-superclasses-p ((cl <mixin-base-class>) lst)
  49.     (let ((last (last-pair lst))
  50.       (not-last (cdr (reverse lst))))
  51.       (and (not (detect (lambda (super)
  52.               (not (or (mixin-class-p super)
  53.                    (eq <object> super))))
  54.             not-last))
  55.        (not (mixin-class-p last)))))
  56.  
  57.   ;; class precedence lists
  58.  
  59.   ;; only duplicate should be object...
  60.   (defmethod compute-precedence-list ((cl <mixin-base-class>)  (direct-superclasses <pair>))
  61.     (cons cl (remove-duplicates-from-end (depth-first-preorder direct-superclasses))))
  62.  
  63.   (defun remove-duplicates-from-end (elements)
  64.     (labels ((fold (elements result)
  65.            (cond
  66.             ((null elements) result)
  67.             ((member (car elements) result eq) (fold (cdr elements) result))
  68.             (t (fold (cdr elements) (cons (car elements) result))))))
  69.         (fold (reverse elements) '())))
  70.  
  71.  
  72.  (defun depth-first-preorder (lst)
  73.    (if (null lst) nil
  74.      (cons (car lst)
  75.        (append (depth-first-preorder (cdr (class-precedence-list (car lst))))
  76.            (depth-first-preorder (cdr lst))))))
  77.          
  78.  ;; slot description creation
  79.  ;; Plan is that mixin-sds do not have accessors,
  80.  ;; except when instantiated into a base class. 
  81.  
  82.  (defclass <mixin-slot-description> (<local-slot-description>)
  83.    ((home-class accessor mixin-sd-home))
  84.    metaclass <slot-description-class>)
  85.  
  86.   (defmethod metaclass-default-slot-description-class ((cl <mixin-class>))
  87.     <mixin-slot-description>)
  88.   
  89.   (defmethod compute-defined-slot-description ((cl <mixin-class>) spec)
  90.     (let ((sd (call-next-method)))
  91.       ((setter mixin-sd-home) sd cl)
  92.       sd))
  93.  
  94.   (defun check-names (lst)
  95.     (labels ((aux (lst seen)
  96.           (cond ((null lst) t)
  97.             ((memq (car lst) seen)
  98.              nil)
  99.             (t (aux (cdr lst) (cons (car lst) seen))))))
  100.         (aux lst nil)))
  101.  
  102.   ;; slot accessors
  103.   ;; refuse to add methods on mixins..
  104.   ;; hope we don't get caught by method lookups later...
  105.   
  106.   (defmethod ensure-slot-reader ((cl <mixin-class>) sd sds fn)
  107.     nil)
  108.  
  109.   (defmethod ensure-slot-writer ((cl <mixin-class>) sd sds fn)
  110.     nil)
  111.  
  112.   ;; have to change ensure-slot-reader s.t. when a 
  113.   ;; new mixin-slot is inherited, we add a method
  114.   
  115.   (defmethod ensure-slot-reader ((cl <mixin-base-class>) (sd <mixin-slot-description>) sds fn)
  116.     (if ((generic-method-lookup-function fn) (list cl)) nil
  117.       (let ((reader (compute-primitive-reader-using-slot-description sd cl sds)))
  118.     (add-method fn
  119.             (make <method> 
  120.               'signature (list cl)
  121.               'function (method-lambda (o) (reader o))))))
  122.     fn)
  123.  
  124.   (defmethod ensure-slot-writer 
  125.     ((cl <mixin-base-class>) (sd <mixin-slot-description>) sds fn)
  126.     (if ((generic-method-lookup-function fn) (list cl <object>)) nil
  127.       (let ((writer (compute-primitive-writer-using-slot-description sd cl sds)))
  128.     (add-method fn
  129.             (make <method> 
  130.               'signature (list cl <object>)
  131.               'function (method-lambda (o v) (writer o v))))))
  132.     fn)
  133.  
  134.   (defmethod allocate ((cl <mixin-class>) lst)
  135.     (error "Can't allocate a mixin class" <Internal-Error> 'error-value cl))
  136.                  
  137.   ;; end module
  138.   )
  139.  
  140.  
  141. ;; Next trick: Mixin-metaclasses.
  142.  
  143. ;;; Define a base-class Point:
  144.  
  145. (defclass <point> ()
  146.   ((x initform 0 accessor point-x initarg x)
  147.    (y initform 0 accessor point-y initarg y))
  148.   )
  149.  
  150. (defclass <colored> ()
  151.   ((color initform 'black initarg color 
  152.       reader color))
  153.   metaclass <mixin-class>)
  154.  
  155. (defgeneric color-of (obj)
  156.   method (((obj <object>)) 'gray)
  157.   method (((obj <colored>))
  158.       (color obj)))
  159.  
  160. (defclass <colored-point> (<colored> <point>) 
  161.   ()
  162.   metaclass <mixin-base-class>)
  163.  
  164. (setq p1 (make <point>))
  165. (color-of p1)
  166.  
  167. (setq p2 (make <colored-point> 'x 1 'y 1 'color 'red))
  168. (color-of p2)
  169.  
  170.